home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / FMenus Example / FMenus Example.p < prev    next >
Encoding:
Text File  |  1992-11-24  |  3.1 KB  |  157 lines  |  [TEXT/PJMM]
  1. program FMenus;
  2.  
  3. { Copyright 1992 Peter N Lewis }
  4. { This source may be used freely for any purposes.  }
  5. { If you can make any money off this file, you're welcome to it! }
  6.  
  7.     uses
  8.         MyTypes, MyFMenus, BaseGlobals;
  9.  
  10.     const
  11.         hstr = 'FMenus Example Help…'; { Should be in a STR# obviously }
  12.         M_Font = 131;
  13.  
  14.     procedure SetEditMenus (themenu, theitem: integer);
  15.     begin
  16.         writeln('SetEditMenus ', themenu : 1, ':', theitem : 1);
  17.     end;
  18.  
  19.     procedure DoQuit;
  20.     begin
  21.         writeln('Quit');
  22.         quitNow := true;
  23.     end;
  24.  
  25.     procedure DoNew;
  26.     begin
  27.         writeln('New');
  28.     end;
  29.  
  30.     procedure DoAbout;
  31.     begin
  32.         writeln('About');
  33.     end;
  34.  
  35.     procedure SetNewMenu (themenu, theitem: integer);
  36.     begin
  37.         writeln('SetNewMenu ', themenu : 1, ':', theitem : 1);
  38.         EnableItem(GetMHandle(themenu), theitem);
  39.     end;
  40.  
  41.     procedure DefaultMenuProc (themenu, theitem: integer);
  42.         var
  43.             save: grafPtr;
  44.             DAName: str255;
  45.             oe: OSErr;
  46.     begin
  47.         if themenu = M_Apple then begin
  48.             GetPort(save);
  49.             GetItem(GetMHandle(M_apple), theitem, DAName);
  50. {oe := OpenDeskAcc(DAName);}
  51.             writeln('OpenDeskAcc ', DAName);
  52.             SetPort(save);
  53.         end
  54.         else if themenu = M_Edit then begin
  55.             writeln('Edit: ', theitem : 1);
  56.         end
  57.         else if themenu = M_Font then begin
  58.             writeln('Font: ', theitem : 1);
  59.         end
  60.         else
  61.             writeln('Default Menu Proc ', themenu : 1, ':', theitem : 1);
  62.     end;
  63.  
  64.     procedure Init;
  65.         var
  66.             oe: OSErr;
  67.             gv: longInt;
  68.             mh: MenuHandle;
  69.     begin
  70.         quitNow := false;
  71.  
  72.         InitFMenus(@DefaultMenuProc);
  73.         mh := GetFMenu(M_Apple);
  74.         AddResMenu(mh, 'DRVR');
  75.         InsertMenu(mh, 0);
  76.         mh := GetFMenu(M_File);
  77.         InsertMenu(mh, 0);
  78.         mh := GetFMenu(M_Edit);
  79.         InsertMenu(mh, 0);
  80.         mh := GetFMenu(M_Font);
  81.         AddResMenu(mh, 'FONT');
  82.         InsertMenu(mh, 0);
  83.  
  84.         SetFCommand(Cquit, @DoQuit);
  85.         SetFCommand(Cnew, @DoNew);
  86.         SetFCommand(Cabout, @DoAbout);
  87.         SetFSetMenu(Cundo, @SetEditMenus);
  88.         SetFSetMenu(Ccut, @SetEditMenus);
  89.         SetFSetMenu(Ccopy, @SetEditMenus);
  90.         SetFSetMenu(Cpaste, @SetEditMenus);
  91.         SetFSetMenu(Cclear, @SetEditMenus);
  92.         SetFSetMenu(Cselectall, @SetEditMenus);
  93.         SetFMenus;
  94.         DrawMenuBar;
  95.  
  96.         InitCursor;
  97.     end;
  98.  
  99.     procedure Finish;
  100.     begin
  101.         FinishFMenus;
  102.     end;
  103.  
  104.     procedure EventLoop;
  105.         var
  106.             dummy: boolean;
  107.             er: eventRecord;
  108.             code: integer;
  109.             wp: windowPtr;
  110.             ch: char;
  111.             mResult: longInt;
  112.     begin
  113.         while not quitNow do begin
  114.             dummy := WaitNextEvent(everyEvent, er, 60, nil);
  115.             case er.what of
  116.                 mouseDown:  begin
  117.                     code := FindWindow(er.where, wp);
  118.                     if wp = nil then begin
  119.                         case code of
  120.                             inMenuBar:  begin
  121.                                 SetFMenus;
  122.                                 mResult := MenuSelect(er.where);
  123.                                 if mResult <> 0 then begin
  124.                                     DoFMenu(HiWord(mResult), LoWord(mResult));
  125.                                 end;
  126.                             end;
  127.                             otherwise
  128.                         end;
  129.                     end;
  130.                 end;
  131.  
  132.                 KeyDown:  begin
  133.                     ch := chr(BAND(er.message, CharCodeMask));
  134.                     mResult := 0;
  135.                     if BAND(er.modifiers, CmdKey) <> 0 then begin
  136.                         SetFMenus;
  137.                         mResult := MenuKey(ch);
  138.                     end;
  139.                     if mResult <> 0 then
  140.                         DoFMenu(HiWord(mResult), LoWord(mResult))
  141.                     else
  142.                         writeln('Key: ', ch, ' [', er.modifiers : 1, ']');
  143.                 end;
  144.                 otherwise
  145.                     ;
  146.             end;
  147.         end;
  148.     end;
  149.  
  150. begin
  151.     Init;
  152.  
  153.     ShowText;
  154.     EventLoop;
  155.  
  156.     Finish;
  157. end.